home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 21 / Cream of the Crop 21 (Terry Blount) (October 1996).iso / os2 / e33el2.zip / emacs / 19.33 / lisp / cal-dst.el < prev    next >
Lisp/Scheme  |  1996-01-20  |  17KB  |  388 lines
  1. ;;; cal-dst.el --- calendar functions for daylight savings rules.
  2.  
  3. ;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Paul Eggert <eggert@twinsun.com>
  6. ;;    Edward M. Reingold <reingold@cs.uiuc.edu>
  7. ;; Keywords: calendar
  8. ;; Human-Keywords: daylight savings time, calendar, diary, holidays
  9.  
  10. ;; This file is part of GNU Emacs.
  11.  
  12. ;; GNU Emacs is free software; you can redistribute it and/or modify
  13. ;; it under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; GNU Emacs is distributed in the hope that it will be useful,
  18. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. ;; GNU General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25. ;; Boston, MA 02111-1307, USA.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;; This collection of functions implements the features of calendar.el and
  30. ;; holiday.el that deal with daylight savings time.
  31.  
  32. ;; Comments, corrections, and improvements should be sent to
  33. ;;  Edward M. Reingold               Department of Computer Science
  34. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  35. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  36. ;;                                   Urbana, Illinois 61801
  37.  
  38. ;;; Code:
  39.  
  40. (require 'calendar)
  41.  
  42. (defvar calendar-current-time-zone-cache nil
  43.   "Cache for result of calendar-current-time-zone.")
  44.  
  45. (defvar calendar-system-time-basis
  46.   (calendar-absolute-from-gregorian '(1 1 1970))
  47.   "Absolute date of starting date of system clock.")
  48.  
  49. (defun calendar-absolute-from-time (x utc-diff)
  50.   "Absolute local date of time X; local time is UTC-DIFF seconds from UTC.
  51.  
  52. X is (HIGH . LOW) or (HIGH LOW . IGNORED) where HIGH and LOW are the
  53. high and low 16 bits, respectively, of the number of seconds since
  54. 1970-01-01 00:00:00 UTC, ignoring leap seconds.
  55.  
  56. Returns the pair (ABS-DATE . SECONDS) where SECONDS after local midnight on
  57. absolute date ABS-DATE is the equivalent moment to X."
  58.   (let* ((h (car x))
  59.      (xtail (cdr x))
  60.          (l (+ utc-diff (if (numberp xtail) xtail (car xtail))))
  61.          (u (+ (* 512 (mod h 675)) (floor l 128))))
  62.     ;; Overflow is a terrible thing!
  63.     (cons (+ calendar-system-time-basis
  64.          ;; floor((2^16 h +l) / (60*60*24))
  65.          (* 512 (floor h 675)) (floor u 675))
  66.       ;; (2^16 h +l) mod (60*60*24)
  67.       (+ (* (mod u 675) 128) (mod l 128)))))
  68.  
  69. (defun calendar-time-from-absolute (abs-date s)
  70.   "Time of absolute date ABS-DATE, S seconds after midnight.
  71.  
  72. Returns the pair (HIGH . LOW) where HIGH and LOW are the high and low
  73. 16 bits, respectively, of the number of seconds 1970-01-01 00:00:00 UTC,
  74. ignoring leap seconds, that is the equivalent moment to S seconds after
  75. midnight UTC on absolute date ABS-DATE."
  76.   (let* ((a (- abs-date calendar-system-time-basis))
  77.          (u (+ (* 163 (mod a 512)) (floor s 128))))
  78.     ;; Overflow is a terrible thing!
  79.     (cons
  80.      ;; floor((60*60*24*a + s) / 2^16)
  81.      (+ a (* 163 (floor a 512)) (floor u 512))
  82.      ;; (60*60*24*a + s) mod 2^16
  83.      (+ (* 128 (mod u 512)) (mod s 128)))))
  84.  
  85. (defun calendar-next-time-zone-transition (time)
  86.   "Return the time of the next time zone transition after TIME.
  87. Both TIME and the result are acceptable arguments to current-time-zone.
  88. Return nil if no such transition can be found."
  89.   (let* ((base 65536);; 2^16 = base of current-time output
  90.      (quarter-multiple 120);; approx = (seconds per quarter year) / base
  91.      (time-zone (current-time-zone time))
  92.      (time-utc-diff (car time-zone))
  93.          hi
  94.      hi-zone
  95.          (hi-utc-diff time-utc-diff)
  96.          (quarters '(2 1 3)))
  97.     ;; Heuristic: probe the time zone offset in the next three calendar
  98.     ;; quarters, looking for a time zone offset different from TIME.
  99.     (while (and quarters (eq time-utc-diff hi-utc-diff))
  100.       (setq hi (cons (+ (car time) (* (car quarters) quarter-multiple)) 0))
  101.       (setq hi-zone (current-time-zone hi))
  102.       (setq hi-utc-diff (car hi-zone))
  103.       (setq quarters (cdr quarters)))
  104.     (and
  105.      time-utc-diff
  106.      hi-utc-diff
  107.      (not (eq time-utc-diff hi-utc-diff))
  108.      ;; Now HI is after the next time zone transition.
  109.      ;; Set LO to TIME, and then binary search to increase LO and decrease HI
  110.      ;; until LO is just before and HI is just after the time zone transition.
  111.      (let* ((tail (cdr time))
  112.         (lo (cons (car time) (if (numberp tail) tail (car tail))))
  113.         probe)
  114.        (while
  115.        ;; Set PROBE to halfway between LO and HI, rounding down.
  116.        ;; If PROBE equals LO, we are done.
  117.        (let* ((lsum (+ (cdr lo) (cdr hi)))
  118.           (hsum (+ (car lo) (car hi) (/ lsum base)))
  119.           (hsumodd (logand 1 hsum)))
  120.          (setq probe (cons (/ (- hsum hsumodd) 2)
  121.                    (/ (+ (* hsumodd base) (% lsum base)) 2)))
  122.          (not (equal lo probe)))
  123.      ;; Set either LO or HI to PROBE, depending on probe results.
  124.      (if (eq (car (current-time-zone probe)) hi-utc-diff)
  125.          (setq hi probe)
  126.        (setq lo probe)))
  127.        hi))))
  128.  
  129. (defun calendar-time-zone-daylight-rules (abs-date utc-diff)
  130.   "Return daylight transition rule for ABS-DATE, UTC-DIFF sec offset from UTC.
  131. ABS-DIFF must specify a day that contains a daylight savings transition.
  132. The result has the proper form for calendar-daylight-savings-starts'."
  133.   (let* ((date (calendar-gregorian-from-absolute abs-date))
  134.      (weekday (% abs-date 7))
  135.      (m (extract-calendar-month date))
  136.      (d (extract-calendar-day date))
  137.      (y (extract-calendar-year date))
  138.          (last (calendar-last-day-of-month m y))
  139.      (candidate-rules
  140.       (append
  141.        ;; Day D of month M.
  142.        (list (list 'list m d 'year))
  143.        ;; The first WEEKDAY of month M.
  144.            (if (< d 8)
  145.                (list (list 'calendar-nth-named-day 1 weekday m 'year)))
  146.        ;; The last WEEKDAY of month M.
  147.            (if (> d (- last 7))
  148.                (list (list 'calendar-nth-named-day -1 weekday m 'year)))
  149.        ;; The first WEEKDAY after day J of month M, for D-6 < J <= D.
  150.            (let (l)
  151.              (calendar-for-loop j from (max 2 (- d 6)) to (min d (- last 8)) do
  152.         (setq l
  153.               (cons
  154.                (list 'calendar-nth-named-day 1 weekday m 'year j)
  155.                l)))
  156.          l)))
  157.      (prevday-sec (- -1 utc-diff)) ;; last sec of previous local day
  158.      (year (1+ y)))
  159.     ;; Scan through the next few years until only one rule remains.
  160.     (while
  161.     (let ((rules candidate-rules)
  162.           new-rules)
  163.       (while
  164.           (let*
  165.           ((rule (car rules))
  166.            (date
  167.             ;; The following is much faster than
  168.             ;; (calendar-absolute-from-gregorian (eval rule)).
  169.             (cond ((eq (car rule) 'calendar-nth-named-day)
  170.                (eval (cons 'calendar-nth-named-absday (cdr rule))))
  171.               ((eq (car rule) 'calendar-gregorian-from-absolute)
  172.                (eval (car (cdr rule))))
  173.               (t (let ((g (eval rule)))
  174.                    (calendar-absolute-from-gregorian g))))))
  175.         (or (equal
  176.              (current-time-zone
  177.               (calendar-time-from-absolute date prevday-sec))
  178.              (current-time-zone
  179.               (calendar-time-from-absolute (1+ date) prevday-sec)))
  180.             (setq new-rules (cons rule new-rules)))
  181.         (setq rules (cdr rules))))
  182.       ;; If no rules remain, just use the first candidate rule;
  183.       ;; it's wrong in general, but it's right for at least one year.
  184.       (setq candidate-rules (if new-rules (nreverse new-rules)
  185.                   (list (car candidate-rules))))
  186.       (setq year (1+ year))
  187.       (cdr candidate-rules)))
  188.     (car candidate-rules)))
  189.  
  190. (defun calendar-current-time-zone ()
  191.   "Return UTC difference, dst offset, names and rules for current time zone.
  192.  
  193. Returns (UTC-DIFF DST-OFFSET STD-ZONE DST-ZONE DST-STARTS DST-ENDS
  194. DST-STARTS-TIME DST-ENDS-TIME), based on a heuristic probing of what the
  195. system knows:
  196.  
  197. UTC-DIFF is an integer specifying the number of minutes difference between
  198.     standard time in the current time zone and Coordinated Universal Time
  199.